Code and Notes (Week 7 Thursday)

module PracWk7 where

-- zipping over functors
maybeUnzip :: Maybe (a, b) -> (Maybe a, Maybe b)
maybeUnzip Nothing = (Nothing, Nothing)
maybeUnzip (Just (a, b)) = (Just a, Just b)

maybeUnzip2 :: Maybe (a, b) -> (Maybe a, Maybe b)
maybeUnzip2 x = (fmap fst x, fmap snd x)

funzip :: Functor f => f (a,b) -> (f a, f b)
funzip x = (fmap fst x, fmap snd x)

-- double functors

-- f is Maybe
-- g is List
maybeListfmap :: (a -> b) -> Maybe [a] -> Maybe [b]
maybeListfmap f Nothing = Nothing
maubeListfmap f (Just as) = Just (fmap f as)

maybeListfmap' :: (a -> b) -> Maybe [a] -> Maybe [b]
maybeListfmap' f ma = fmap (fmap f) ma
-- maybeListfmap' = fmap.fmap

doubleFmap :: (Functor f, Functor g) => (a -> b) -> f(g a) -> f(g b)
doubleFmap f m = fmap (fmap f) m -- or fmap.fmap
-- examples you can run
-- doubleFmap succ (Just [1, 2, 3, 4])
-- doubleFmap succ [Nothing, Just 4, Nothing, Just 9]

-- stream functors
data Stream a = SCons a (Stream a)
  deriving (Show, Eq)

myMapMaybe :: (a -> b) -> Maybe a -> Maybe b
myMapMaybe _ Nothing = Nothing
myMapMaybe f (Just a) = Just (f a)

myMapList :: (a -> b) -> [a] -> [b]
myMapList _ [] = []
myMapList f (h:r) = f h : myMapList f r

-- f :: a -> b
-- a :: a
-- i need a b
-- sa :: Stream b
-- i need Stream a
instance Functor Stream where
  fmap :: (a -> b) -> Stream a -> Stream b
  fmap f (SCons a sa) = SCons (f a) (fmap f sa)

consStream :: Int -> Stream Int
consStream a = SCons a (consStream (a+1))

takeStream :: Int -> Stream a -> [a]
takeStream x (SCons h r) | x<1 = []
                         | otherwise = h : takeStream (x-1) r


-- trie functors
data Trie v = Trie v [(Char,Trie v)]
  deriving (Eq,Show)

-- what do we want here:
-- we have [(Char, Trie a)]
-- we want [(Char, Trie b)]

thing :: (a -> b) -> [(Char, a)] -> [(Char, b)]
--thing f l = map (\(c, t) -> (c, f t)) l
thing = doubleFmap


tripleFmap :: (Functor f, Functor g, Functor h) => (a -> b) -> f(g(h a)) -> f(g(h b))
tripleFmap = fmap.fmap.fmap

-- we have:
-- f :: a -> b
instance Functor Trie where
  fmap :: (a -> b) -> Trie a -> Trie b
  fmap f (Trie a lct) = Trie (f a) $ tripleFmap f lct
  --fmap f (Trie a lct) = Trie (f a) $ map (\(c, t) -> (c, fmap f t)) lct


-- continuation functors
data Cont c a = Cont ((a -> c) -> c)

{-
  we have (as always) a function:
    f :: a -> b
  we want to transorm a "Cont c a" into a "Cont c b"
  we are given a "Cont c a" which contains:
    g :: ((a -> c) -> c)
  we now need to produce a "Cont c b" which contains:
    g' :: ((b -> c) -> c)
-}

-- at the point below, we have access to:
-- f :: a -> b
-- g :: ((a -> c) -> c)
-- g' :: b -> c
-- we need to produce: a "c"

-- Cont c a must contain a function :: ((a -> c) -> c)
-- Cont c b must contain a function :: ((b -> c) -> c)

instance Functor(Cont c) where
  fmap :: (a -> b) -> Cont c a -> Cont c b
  fmap f (Cont g) = Cont (\g' -> g $ g'.f )



-- https://tinyurl.com/376nycbs

-- MONADS

-- noughts and crosses monads
data XO = X | O deriving (Eq,Show)
type Board = [Maybe XO]

initialBoard :: Board
initialBoard =
  [Nothing,Nothing,Nothing,
   Nothing,Nothing,Nothing,
   Nothing,Nothing,Nothing]

{- fillBoard xo b returns the
   list of all possible next board states,
   after player xo has made a move on board b -}
fillBoard :: XO -> Board -> [Board]
fillBoard xo [] = []
fillBoard xo (Just x:xs) = map (Just x:) $ fillBoard xo xs
fillBoard xo (Nothing:xs) = (Just xo:xs):map (Nothing:) (fillBoard xo xs)

switchTurn :: XO -> XO
switchTurn X = O
switchTurn O = X

{- All possible board states after the next 3 moves
 -}
fillBoard3 :: XO -> Board -> [Board]
fillBoard3 xo b =
  let bs = fillBoard xo b
      bs' = concat (map (fillBoard (switchTurn xo)) bs)
      bs'' = concat (map (fillBoard xo) bs')
  in bs''

{- Identify the annoying recurring pattern in the function
   above, and see if you can crystalise it into
   can crystalise it into a bind operation.
   Then use it to rewrite the above function.
 -}
bindL :: [a] -> (a -> [b]) -> [b]
-- bindL l f = concatMap f l
bindL [] _ = []
bindL (h:r) f = f h ++ bindL r f

{- Implement this generalisation of fillBoard3
   which does n moves instead, using bindL
   and recursion.
 -}
fillBoardN :: Int -> XO -> Board -> [Board]
fillBoardN n x b | n<1 = [b]
                 | otherwise = (fillBoard x b) `bindL` (fillBoardN (n-1) (switchTurn x))

fillBoard3' :: XO -> Board -> [Board]
fillBoard3' xo b = let xo' = switchTurn xo in
  fillBoard xo b `bindL` fillBoard xo' `bindL` fillBoard xo



-- the nothingburger monad

data NothingBurger a = NothingBurger a deriving (Eq,Show)

bindN :: NothingBurger a -> (a -> NothingBurger b) -> NothingBurger b
bindN (NothingBurger a) f = f a

instance Functor NothingBurger where
  fmap :: (a -> b) -> NothingBurger a -> NothingBurger b
  fmap f (NothingBurger a) = NothingBurger (f a)

-- the absolutelynothing monad

data AbsolutelyNothing a = AbsolutelyNothing deriving (Eq,Show)

bindAN :: AbsolutelyNothing a ->
         (a -> AbsolutelyNothing b) ->
         AbsolutelyNothing b
bindAN _ _ = AbsolutelyNothing

instance Functor AbsolutelyNothing where
  fmap :: (a -> b) -> AbsolutelyNothing a -> AbsolutelyNothing b
  fmap _ _ = AbsolutelyNothing